Pascal Super Library/Pascal Super Library (CW International)(1997).bin/DELPHI32/DEBUG/STAKWK10/STAKWK10.ZIP/STAKLOW.PAS

Pascal/Delphi Source File | 1996-05-10 | 6KB | 258 lines

unit StakLow;
{ Low level Delphi 2.0 debugger fix unit.  Copyright (c) 1996, D.J. Murdoch }
{ THIS VERSION IS NOT FOR DISTRIBUTION!!!! }
{$D-  We don't want this code to be reported }
{$OPTIMIZATION off } { And we don't want it optimized }
interface

uses classes,sysutils;

type
  EDebug = class(Exception);

  TRange = class
    start, stop : integer;
  end;

  TRangeList = class(TList)
    { This is a list of ranges of addresses to report }
    destructor destroy; override;

    procedure FreeAll;
    { Frees all the ranges }

    function InRange(target:pointer):boolean;
    { Checks whether start <= target <= stop
      for some entry in the list }

    procedure ReadMapFile(filename:string);
    { Reads a .MAP file to initialize }

    procedure HandleException(Sender: TObject; E: Exception);
    { Possible handler for Application.OnException }
  end;

procedure ExceptHandler(ExceptObject: TObject; ExceptAddr: Pointer);
{ Handler to use in place of ExceptProc }

procedure WalkStack;
{ Walks through the stack, triggering an EDebug exception at everything that
  looks as though it might be a return address }

type
  TContinueFunc = function:boolean;
  TWarnProc = procedure;
var
  StackWalker : TRangeList;
  FoundMap : boolean;
  StopWalker : boolean;
  WalkerActive : boolean;
  ContinueFunc : TContinueFunc;
  Walking : boolean;

implementation

procedure TRangeList.FreeAll;
var
  i : integer;
begin
  for i:=0 to pred(count) do
    TRange(Items[i]).Free;
  Count := 0;
end;

destructor TRangeList.Destroy;
begin
  FreeAll;
  inherited;
end;

function TRangeList.InRange(target:pointer):boolean;
var
  i : Integer;
begin
  result := false;
  for i:=0 to pred(count) do
    with TRange(Items[i]) do
      if (start <= integer(target)) and (integer(target) <= stop) then
      begin
        result := true;
        exit;
      end;
end;

procedure TRangeList.ReadMapFile(filename:string);
var
  map : textfile;
  line : string;
  range : TRange;
  mapshift : integer;
  buffer : array[1..8192] of byte;
begin
  mapshift := 0;
  FreeAll;
  assignfile(map,filename);
  settextbuf(map,buffer);
  {$i-}
  reset(map);
  {$i+}
  if ioresult = 0 then
  begin
    while not eof(map) do
    begin
      readln(map,line);
      if pos('Publics by Value',line) > 0 then
        break;
    end;
    while not eof(map) do
    begin
      readln(map,line);
      if pos('TextStart',line) > 0 then
      begin
        mapshift := integer(@TextStart) - StrToInt('$'+copy(line,7,8));
        break;
      end;
    end;
    while not eof(map) do
    begin
      readln(map,line);
      if pos('Line numbers for ',line) > 0 then
      begin
        range := TRange.Create;
        readln(map,line);
        if line = '' then
          readln(map,line);
        range.start := mapshift + StrToInt('$'+copy(line,13,8));
        range.stop := mapshift + StrToInt('$'+copy(line,length(line)-7,8));
        while not eof(map) do
        begin
          readln(map,line);
          if line = '' then
            break;
          range.stop := mapshift + StrToInt('$'+copy(line,length(line)-7,8));
        end;
        Add(range);
      end;
    end;
    closefile(map);
  end;
  if count = 0 then
  begin
    FoundMap := false;
    range := TRange.create;
    range.start := integer(@TextStart);
    range.stop := integer(@HeapAllocFlags);
    Add(range);
  end
  else
    FoundMap := true;
end;

procedure WalkStack;
var
  target : pointer;
  hitnum : integer;
  saveclass : TClass;
  p,stackstart,stacktop : ^pointer;
begin
  if walking then
    exit;
  stopwalker := false;
  walking := true;
  saveclass := ExceptionClass;
  asm
    mov stackstart,esp
  end;
  ExceptionClass := Nil;  { Run until we hit the top of the stack, but don't
                            let the debugger know about it. }
  p := stackstart;
  try
    repeat
      target := p^;
      inc(p);
    until false;
  except
    stacktop := p;
  end;
  ExceptionClass := SaveClass;

  hitnum := 0;
  p := stackstart;
  try
    while (not StopWalker) and (integer(p) < integer(stacktop)) do
    begin
      ExceptionClass := Nil;
      target := p^;
      ExceptionClass := saveclass;
      if stackwalker.inrange(target) then
      begin
        if assigned(ContinueFunc) and not ContinueFunc then
          break;
        inc(hitnum);
        if hitnum > 0 then
          try
            raise edebug.create(format('Hit number %d at %x, %d%% done',
                                       [hitnum,integer(target),
                                        ((integer(p)-integer(stackstart))*100) div
                                         (integer(stacktop)-integer(stackstart))]))
                  at target;
          except
          end;
      end;
      inc(p);
    end;
  except
  end;
  walking := false;
end;

type
  thandler = procedure(ExceptObject: TObject; ExceptAddr: Pointer);
var
  saveexcept : thandler;

procedure fpuinit; assembler;
const cwDefault: Word = $1332 { $133F};
begin
  asm
        FNINIT
        FWAIT
        FLDCW   cwDefault
  end;
end;

procedure ExceptHandler(ExceptObject: TObject; ExceptAddr: Pointer);
begin
  {  fpuinit; }
  if WalkerActive then
    WalkStack;
  saveexcept(ExceptObject,ExceptAddr);
end;

procedure TRangeList.HandleException(Sender: TObject; E: Exception);
begin
{  fpuinit; }
  ShowException(E,ExceptAddr);
  if WalkerActive then
    WalkStack;
end;

initialization
  saveexcept := THandler(ExceptProc);
  if debughook <> 0 then
  begin
    stackwalker := TRangeList.Create;
    FoundMap := false;
    stackwalker.readmapfile(ChangeFileExt(paramstr(0),'.map'));
    ExceptProc := @ExceptHandler;
    ContinueFunc := nil;
    WalkerActive := true;
    Walking := false;
  end
  else
    StackWalker := Nil;
finalization
  ExceptProc := @saveexcept;
  stackwalker.free;
end.